home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / make-declare.lsp < prev    next >
Encoding:
Text File  |  1994-05-07  |  2.7 KB  |  80 lines
  1. ;; By W. Schelter
  2. ;; Usage: (si::proclaim-file "foo.lsp") (compile-file "foo.lsp")
  3.  
  4. (in-package 'si)
  5.  
  6. ;; You may wish to adjust the following to output the proclamations
  7. ;; for inclusion in a file.  All fixed arg functions should be proclaimed
  8. ;; before their references for maximum efficiency.
  9.  
  10. ;; CAVEAT: The following code only checks for fixed args, it does
  11. ;; not check for single valuedness BUT does make a proclamation
  12. ;; to that effect.  Unfortunately it is impossible to tell about
  13. ;; multiple values without doing a full compiler type pass over 
  14. ;; all files in the relevant system.   However the GCL compiler should
  15. ;; warn if you inadvertantly proclaim foo to be single valued and then try
  16. ;; to use more than one value.  
  17.  
  18. (DEFVAR *DECLARE-T-ONLY* NIL)
  19. (DEFUN PROCLAIM-FILE (NAME &OPTIONAL *DECLARE-T-ONLY*)
  20.   (WITH-OPEN-FILE 
  21.       (FILE NAME
  22.             :DIRECTION :INPUT)
  23.     (LET ((EOF (CONS NIL NIL)))
  24.       (LOOP
  25.        (LET ((FORM (READ FILE NIL EOF)))
  26.          (COND ((EQ EOF FORM) (RETURN NIL))
  27.                ((MAKE-DECLARE-FORM FORM ))))))))
  28.  
  29. (DEFVAR *DEFUNS* '(DEFUN))
  30.  
  31. (DEFUN MAKE-DECLARE-FORM (FORM)
  32. ; !!!
  33.   (WHEN
  34.         (LISTP FORM)
  35.    (COND ((MEMBER (CAR FORM) '(EVAL-WHEN ))
  36.           (DOLIST (V (CDDR FORM)) (MAKE-DECLARE-FORM V)))
  37.          ((MEMBER (CAR FORM) '(PROGN ))
  38.           (DOLIST (V (CDR FORM)) (MAKE-DECLARE-FORM V)))
  39.          ((MEMBER (CAR FORM) '(IN-PACKAGE DEFCONSTANT))
  40.           (EVAL FORM))
  41.          ((MEMBER (CAR FORM) *DEFUNS*)
  42.           (COND
  43.            ((AND
  44.              (CONSP (CADDR FORM))
  45.              (NOT (MEMBER '&REST (CADDR FORM)))
  46.              (NOT (MEMBER '&BODY (CADDR FORM)))
  47.              (NOT (MEMBER '&KEY (CADDR FORM)))
  48.              (NOT (MEMBER '&OPTIONAL (CADDR FORM))))
  49.              ;;could print  declarations here.
  50.         ;(print (list (cadr form)(ARG-DECLARES (THIRD FORM)(cdddr FORM))))
  51.             (FUNCALL 'PROCLAIM
  52.                      (LIST  'FUNCTION
  53.                             (CADR FORM)
  54.                 (ARG-DECLARES (THIRD FORM) (cdddr FORM))
  55.                             T))))))))
  56.  
  57. (DEFUN ARG-DECLARES (ARGS DECLS &AUX ANS)
  58.   (COND ((STRINGP (CAR DECLS)) (SETQ DECLS (CADR DECLS)))
  59.     (T (SETQ DECLS (CAR DECLS))))
  60.   (COND ((AND (not *declare-t-only*)
  61.            (CONSP DECLS) (EQ (CAR DECLS ) 'DECLARE))
  62.      (DO ((V ARGS (CDR V)))
  63.          ((OR (EQ (CAR V) '&AUX)
  64.           (NULL V))
  65.           (NREVERSE ANS))
  66.          (PUSH (DECL-TYPE (CAR V) DECLS) ANS)))
  67.     (T (MAKE-LIST (- (LENGTH args)
  68.              (LENGTH (MEMBER '&AUX args)))
  69.               :INITIAL-ELEMENT T))))
  70.  
  71. (DEFUN DECL-TYPE (V DECLS)
  72.   (DOLIST (D (CDR DECLS))
  73.       (CASE (CAR D)
  74.         (TYPE (IF (MEMBER V (CDDR D))
  75.             (RETURN-FROM DECL-TYPE (SECOND D))))
  76.         ((FIXNUM CHARACTER FLOAT LONG-FLOAT SHORT-FLOAT )
  77.          (IF (MEMBER V (CDR D)) (RETURN-FROM DECL-TYPE (CAR D))))))
  78.   T)
  79.                 
  80.